home *** CD-ROM | disk | FTP | other *** search
/ Workbench Add-On / Workbench Add-On - Volume 1.iso / BBS-Archive / Dev / GNU-TILE-FORTH.lha / tst / objects.tst < prev    next >
Text File  |  1992-05-19  |  4KB  |  246 lines
  1. .( Loading Objects test...) cr
  2.  
  3. #include objects.f83
  4.  
  5. objects string forth definitions
  6.  
  7.  
  8. \ The set of messages needed for this example
  9.  
  10. message initiate ( self -- )
  11.  
  12. message isKindOf ( class self -- boolean)
  13. message isMemberOf ( class self -- boolean)
  14. message respondsTo ( message self -- boolean)
  15.  
  16. message instanceSize ( self -- num)
  17. message copy ( self -- object)
  18. message shallowCopy ( self -- object)
  19. message deepCopy ( self -- object)
  20.  
  21. message doesNotUnderstand ( message self -- )
  22. message subclassResponsibility ( self -- )
  23. message shouldNotImplement ( self -- )
  24.  
  25. message perform ( message self -- )
  26.  
  27. message basicWrite ( self -- )
  28. message write ( self -- )
  29. message read ( self -- )
  30.  
  31. message where ( self -- x y)
  32. message position ( x y self -- )
  33.  
  34. message balance ( self -- x)
  35. message owner ( self -- x)
  36. message deposit ( x self -- )
  37. message withdraw ( x self -- )
  38. message balance ( self -- x)
  39.  
  40.  
  41. \ A class hierarchy with Object, Point, and Account
  42.  
  43. nil subclass Object ( -- )
  44.  
  45. method initiate ( self -- )
  46.   basicWrite ." initiated" cr
  47. ;
  48.  
  49. method isKindOf ( class self -- bool)
  50.   class
  51.   begin
  52.     2dup =
  53.     if 2drop true exit then
  54.     superclass dup 0=
  55.   until
  56.   2drop false
  57. ;
  58.  
  59. method isMemberOf ( class self -- bool)
  60.   class =
  61. ;
  62.  
  63. method respondsTo ( message self -- bool)
  64.   class canUnderstand
  65. ;
  66.  
  67. method instanceSize ( self -- num)
  68.   class basicInstanceSize
  69. ;
  70.  
  71. method copy ( self -- object) 
  72.   shallowCopy
  73. ;
  74.  
  75. method shallowCopy ( self -- object)
  76.   here swap 2dup instanceSize dup allot cmove
  77. ;
  78.  
  79. method deepCopy ( self -- object)
  80.   copy
  81. ;
  82.  
  83. method doesNotUnderstand ( message self -- )
  84.   basicWrite ." does not understand: " .message cr abort
  85. ;
  86.  
  87. method subclassResponsibility ( message self -- )
  88.   basicWrite ." subclass should have overridden: " .message cr abort
  89. ;
  90.  
  91. method shouldNotImplement ( message self -- )
  92.   basicWrite ." should not implement: " .message cr abort
  93. ;
  94.  
  95. method perform ( message self -- )
  96.   tuck class send
  97. ;
  98.   
  99. method write ( self -- )
  100.   basicWrite
  101. ;
  102.  
  103. method basicWrite ( self -- )
  104.   dup .class ." #" .
  105. ;
  106.  
  107. subclass.end
  108.  
  109.  
  110. Object subclass Point ( x y -- )
  111.  
  112.   long +x ( self -- addr)
  113.   long +y ( self -- addr)
  114.  
  115. method initiate ( x y self -- )
  116.   dup >r super initiate r> position
  117. ;
  118.  
  119. method position ( x y self -- )
  120.   tuck +y ! +x ! 
  121. ;
  122.  
  123. method where ( self -- x y)
  124.   dup +x @ swap +y @
  125. ;
  126.  
  127. method write ( self -- )
  128.   dup super write where ." x: " swap . ." :y " .
  129. ;
  130.  
  131. subclass.end
  132.  
  133.  
  134. Object subclass Account ( x -- )
  135.  
  136.   long +owner ( self -- addr)
  137.   long +balance ( self -- addr)
  138.  
  139. method initiate ( x self -- )
  140.   dup >r super initiate r>
  141.   0 over +balance ! +owner !
  142. ;
  143.  
  144. method balance ( self -- x)
  145.   +balance @
  146. ;
  147.  
  148. method owner ( self -- x)
  149.   +owner @
  150. ;
  151.  
  152. method deposit ( x self -- )
  153.   +balance +!
  154. ;
  155.  
  156. method withdraw ( money self -- )
  157.   swap negate swap +balance +!
  158. ;
  159.  
  160. method write ( self -- )
  161.   dup super write
  162.   ." owner: " dup owner $print space
  163.   ." balance: " balance .
  164. ;
  165.  
  166. subclass.end
  167.  
  168. : DEBUG ;
  169.  
  170. #ifdef DEBUG
  171.  
  172. message traceOn ( self  -- )
  173. message traceOff ( self -- )
  174.  
  175. nil subclass TraceableObject ( class -- )
  176.  
  177.   ptr +real-object ( self -- addr)
  178.   long +traced ( self -- addr)
  179.  
  180. method initiate ( class self -- )
  181.   >r new-instance r@ +real-object ! r> traceOff
  182. ;
  183.  
  184. method doesNotUnderstand ( message self -- )
  185.   dup +traced @
  186.   if 2dup +real-object @
  187.     basicWrite ." called with the message: " .message cr
  188.   then
  189.   +real-object @ tuck class send
  190. ;
  191.  
  192. method traceOff ( self -- )
  193.   false swap +traced !
  194. ;
  195.  
  196. method traceOn ( self -- )
  197.   true swap +traced !
  198. ;
  199.  
  200. subclass.end
  201.  
  202. #else
  203.  
  204. : TraceableObject ( -- ) ;
  205. : traceOff ( self -- ) drop ;
  206. : traceOn ( self -- ) drop ;
  207.  
  208. #then
  209.  
  210.  
  211. \ Create some objects and send them a message or two
  212.  
  213. Object instance anObject
  214. anObject write cr
  215. anObject read
  216. cr
  217.  
  218. 10 10 Point instance aPoint
  219. aPoint write cr
  220. -10 -10 aPoint position
  221. aPoint write cr
  222. aPoint read 
  223. cr
  224.  
  225. " Mikael" Account instance anAccount 
  226. anAccount write cr
  227. 100 anAccount deposit
  228. anAccount write cr
  229. 98 anAccount withdraw
  230. anAccount write cr
  231. cr
  232.  
  233.  
  234. \ Demonstrate a traceable object class (a proxy class)
  235.  
  236. 10 10 Point TraceableObject instance aTracedPoint
  237. aTracedPoint traceOn
  238. aTracedPoint write cr
  239. -10 -10 aTracedPoint position
  240. aTracedPoint write cr
  241. aTracedPoint read
  242. cr 
  243.  
  244. forth only
  245.  
  246.